home *** CD-ROM | disk | FTP | other *** search
/ Fritz: All Fritz / All Fritz.zip / All Fritz / FILES / PROGMISC / FORTRAN2.LZH / NAE3.FOR < prev    next >
Encoding:
Text File  |  1988-02-08  |  11.6 KB  |  378 lines
  1.       SUBROUTINE NAE3 ( NREAD, NWRITE, NUM, MAX, IARRAY,
  2.      $                  IARRAY2, IARRAY3, ERROR )
  3. C*
  4. C*                  *******************************
  5. C*                  *******************************
  6. C*                  **                           **
  7. C*                  **          NAE3             **
  8. C*                  **                           **
  9. C*                  *******************************
  10. C*                  *******************************
  11. C*
  12. C*     SUBPROGRAM :
  13. C*          NIFTY ARRAY EDITOR 3
  14. C*
  15. C*     AUTHOR :
  16. C*          ART RAGOSTA
  17. C*          MS 207-5
  18. C*          AMES RESEARCH CENTER
  19. C*          MOFFETT FIELD, CALIF  94035
  20. C*          (415) 694-5578
  21. C*
  22. C*     PURPOSE :
  23. C*          TO ENABLE THE SCREEN-ORIENTED EDITING OF 3 ARRAYS.
  24. C*
  25. C*     METHODOLOGY :
  26. C*          USES DEC RUN TIME LIBRARY CALLS FOR SCREEN MANIPULATION.
  27. C*
  28. C*     INPUT ARGUMENTS :
  29. C*          NREAD  - KEYBOARD LOGICAL UNIT NUMBER.
  30. C*          NWRITE - SCREEN LOGICAL UNIT NUMBER.
  31. C*          NUM    - NUMBER OF ELEMENTS IN ARRAYS.
  32. C*          MAX    - THE DIMENSION OF ARRAYS.
  33. C*          IARRAY - THE FIRST DATA ARRAY.
  34. C*          IARRAY2- THE SECOND DATA ARRAY.
  35. C*          IARRAY3- THE THIRD DATA ARRAY.
  36. C*
  37. C*     OUTPUT ARGUMENTS :
  38. C*          ERROR  - .TRUE. IF AN UNRECOVERABLE ERROR WAS ENCOUNTERED.
  39. C*
  40. C*     INTERNAL WORK AREAS :
  41. C*          STRING - TEMPORARY STORAGE FOR INPUT STRING.
  42. C*
  43. C*     COMMON BLOCKS :
  44. C*          NONE
  45. C*
  46. C*     FILE REFERENCES :
  47. C*          NREAD, NWRITE
  48. C*
  49. C*     DATA BASE ACCESS :
  50. C*          NONE
  51. C*
  52. C*     SUBPROGRAM REFERENCES :
  53. C*          CLEAR,  NSTAT,  WRITA3,  GOTOXY,  CAPS,   LEFT,  MBELL
  54. C*          STAT,   WAIT,   WRITL3,  REVLF,   GETOKE, RIGHT, SRESET
  55. C*
  56. C*     ERROR PROCESSING :
  57. C*          CHECK FOR VALID COMMANDS.
  58. C*          CHECK FOR RIGHT NUMBER OF ENTRIES ON A LINE.
  59. C*
  60. C*     TRANSPORTABILITY LIMITATIONS :
  61. C*          NOT TRANSPORTABLE.
  62. C*
  63. C*     ASSUMPTIONS AND RESTRICTIONS :
  64. C*          VT-100 COMPATIBLE TERMINALS ONLY.
  65. C*
  66. C*     LANGUAGE AND COMPILER :
  67. C*          ANSI FORTRAN 77
  68. C*
  69. C*     VERSION AND DATE :
  70. C*          VERSION I.0      4-FEB-85
  71. C*
  72. C*     CHANGE HISTORY :
  73. C*           4-FEB-85    INITIAL VERSION
  74. C*
  75. C***********************************************************************
  76. C*
  77.       CHARACTER *80 STRING
  78.       CHARACTER *20 TOKE
  79.       CHARACTER *1 ESC, TYPE
  80.       LOGICAL ERROR, DOWN, ERR
  81.       DIMENSION IARRAY(MAX), IARRAY2(MAX), IARRAY3(MAX)
  82.       DATA ESC/27/
  83. C
  84. C  NUM    - THE NUMBER OF ELEMENTS IN IARRAY
  85. C  MAX    - THE MAXIMUM DIMENSION OF IARRAY
  86. C  IARRAY - THE DATA TO BE EDITED
  87. C  IARRAY2- THE DATA TO BE EDITED
  88. C  IARRAY3- THE DATA TO BE EDITED
  89. C  NARRAY - THE NUMBER OF ARRAYS ( 1 FOR THIS VERSION )
  90. C  ERROR  - INTERNAL ERROR FLAG
  91. C  DOWN   - .TRUE. IF THE DEFAULT DIRECTION IS DOWN
  92. C  IPTR   - THE ARRAY ELEMENT WE ARE PRESENTLY POINTING TO
  93. C  IX     - X LOCATION OF CURSOR (ALWAYS 1 IN PRESENT VERSION)
  94. C  IY     - Y LOCATION OF CURSOR (BETWEEN 2 AND 24)
  95. C  NREAD  - KEYBOARD UNIT NUMBER
  96. C  NWRITE - SCREEN UNIT NUMBER
  97. C  STRING - INPUT BUFFER
  98. C  ISTART - THE FIRST ELEMENT IN THE ARRAY TO BE DISPLAYED ON THE SCREEN
  99. C
  100.       ERROR = .FALSE.
  101.       NARRAY = 3
  102.       IF ( NUM .GT. MAX ) THEN
  103.          ERROR = .TRUE.
  104.          RETURN
  105.       ENDIF
  106.       DOWN = .TRUE.
  107.       IX   = 1
  108.       IY   = 2
  109. C
  110. C --- DISPLAY INITIAL STATUS, DISPLAY FIRST PART OF ARRAYS
  111. C
  112.       IPTR = 0
  113.       IF ( NUM .GE. 1 ) IPTR = 1
  114.       ISTART = IPTR
  115.       CALL NSTAT ( IX, IY, NUM, DOWN )
  116.       CALL WRITA3 ( NWRITE, NUM, IARRAY, IARRAY2, IARRAY3, ISTART )
  117.       CALL GOTOXY ( NWRITE, IX, IY )
  118. C
  119. C --- REPEAT UNTIL DONE
  120. C
  121. 100   READ ( NREAD, 900, END=1000, ERR=1000 ) STRING
  122.       CALL CAPS ( STRING )
  123.       CALL LEFT ( STRING )
  124.       IF (STRING(1:1) .EQ. 'A') THEN
  125. C
  126. C ----- 'ADD' COMMAND
  127. C
  128.          IF (NUM .EQ. MAX) THEN
  129.             CALL MBELL ( NWRITE )
  130.             CALL STAT ( IX, IY, ' Arrays full, insert ignored. ' )
  131.             CALL WAIT ( 3 )
  132.             CALL NSTAT ( IX, IY, NUM, DOWN )
  133.          ELSE
  134.             IARRAY(NUM+1) = 0
  135.             IARRAY2(NUM+1) = 0
  136.             IARRAY3(NUM+1) = 0
  137.             NUM = NUM + 1
  138.             CALL NSTAT ( IX, IY, NUM, DOWN )
  139.             ISTART = NUM - 21
  140.             IF (ISTART .LE. 0)ISTART = 1
  141.             IF (NUM .EQ. 0 )ISTART = 0
  142.             CALL WRITA3 (NWRITE, NUM, IARRAY, IARRAY2, IARRAY3, ISTART)
  143.             IPTR = NUM
  144.             IY = MIN0 ( NUM+1, 23 )
  145.             IF (NUM .EQ. 0) IY = 2
  146.             CALL GOTOXY ( NWRITE, IX, IY )
  147.          ENDIF
  148.       ELSE IF (STRING(1:1) .EQ. 'B') THEN
  149. C
  150. C ----- 'BEGIN' COMMAND
  151. C
  152.          IPTR = 0
  153.          IF (NUM .GE. 1) IPTR = 1
  154.          ISTART = IPTR
  155.          CALL WRITA3 ( NWRITE, NUM, IARRAY, IARRAY2, IARRAY3, ISTART )
  156.          IY = 2
  157.          CALL GOTOXY ( NWRITE, IX, IY )
  158. C
  159.       ELSE IF (STRING(1:1) .EQ. 'D') THEN
  160. C
  161. C ----- 'DELETE' COMMAND
  162. C
  163.          IF (NUM .GT. 0) THEN
  164.             NUM = NUM - 1
  165.             IF (IPTR .EQ. NUM+1) THEN
  166.                IPTR = NUM
  167.                ISTART = ISTART - 1
  168.                IF ( ISTART .LE. 0 ) THEN
  169.                   ISTART = 1
  170.                   IY = IY - 1
  171.                ENDIF
  172.             ELSE
  173.                DO 110 II = IPTR, NUM
  174.                   IARRAY(II) = IARRAY(II+1)
  175.                   IARRAY2(II) = IARRAY2(II+1)
  176.                   IARRAY3(II) = IARRAY3(II+1)
  177. 110               CONTINUE
  178.                IF ( ISTART+22 .GT. NUM )ISTART = ISTART - 1
  179.                IF ( ISTART .LE. 0 )ISTART = 1
  180.             ENDIF
  181.             IF (NUM .EQ. 0) THEN
  182.                ISTART = 0
  183.                IY = 2
  184.             ENDIF
  185.             CALL NSTAT ( IX, IY, NUM, DOWN )
  186.             CALL WRITA3 (NWRITE, NUM, IARRAY, IARRAY2, IARRAY3, ISTART)
  187.          ENDIF
  188.          CALL GOTOXY ( NWRITE, IX, IY )
  189. C
  190.       ELSE IF (STRING(1:1) .EQ. 'E') THEN
  191. C
  192. C ----- 'END' COMMAND
  193. C
  194.          ISTART = NUM - 21
  195.          IF (ISTART .LE. 0)ISTART = 1
  196.          IF (NUM .EQ. 0 )ISTART = 0
  197.          CALL WRITA3 ( NWRITE, NUM, IARRAY, IARRAY2, IARRAY3, ISTART )
  198.          IPTR = NUM
  199.          IY = MIN0 ( NUM+1, 23 )
  200.          IF (NUM .EQ. 0) IY = 2
  201.          CALL GOTOXY ( NWRITE, IX, IY )
  202. C
  203.       ELSE IF (STRING(1:1) .EQ. 'I') THEN
  204. C
  205. C ----- 'INSERT' COMMAND
  206. C
  207.          IF (NUM .EQ. MAX) THEN
  208.             CALL MBELL ( NWRITE )
  209.             CALL STAT ( IX, IY, ' Arrays full, insert ignored. ' )
  210.             CALL WAIT ( 3 )
  211.             CALL NSTAT ( IX, IY, NUM, DOWN )
  212.          ELSE
  213.             IF (IPTR .LE. NUM) THEN
  214.                DO 120 II = NUM, IPTR, -1
  215.                   IARRAY(II+1) = IARRAY(II)
  216.                   IARRAY2(II+1) = IARRAY2(II)
  217.                   IARRAY3(II+1) = IARRAY3(II)
  218. 120               CONTINUE
  219.                IARRAY(IPTR) = 0
  220.                IARRAY2(IPTR) = 0
  221.                IARRAY3(IPTR) = 0
  222.             ELSE
  223.                IARRAY(NUM+1) = 0
  224.                IARRAY2(NUM+1) = 0
  225.                IARRAY3(NUM+1) = 0
  226.             ENDIF
  227.             NUM = NUM + 1
  228.             CALL NSTAT ( IX, IY, NUM, DOWN )
  229.             CALL WRITA3 (NWRITE, NUM, IARRAY, IARRAY2, IARRAY3, ISTART)
  230.             CALL GOTOXY ( NWRITE, IX, IY )
  231.          ENDIF
  232. C
  233.       ELSE IF (STRING(1:1) .EQ. 'Q') THEN
  234.          GO TO 1000
  235. C
  236.       ELSE IF (STRING(1:1) .EQ. 'R') THEN
  237. C
  238. C ----- 'REPAINT' SCREEN
  239. C
  240.          CALL WRITA3 ( NWRITE, NUM, IARRAY, IARRAY2, IARRAY3, ISTART )
  241.          CALL GOTOXY ( NWRITE, IX, IY )
  242. C
  243.       ELSE IF (STRING(1:1) .EQ. 'S') THEN
  244. C
  245. C ----- 'SCROLL' DIRECTION TOGGLE
  246. C
  247.          DOWN = .NOT. DOWN
  248.          CALL NSTAT ( IX, IY, NUM, DOWN )
  249.          CALL GOTOXY ( NWRITE, IX, IY )
  250. C
  251.       ELSE IF ((STRING(1:1) .EQ. '?') .OR. (STRING(1:1) .EQ. 'H')) THEN
  252. C
  253. C ----- 'HELP' COMMAND
  254. C
  255.          CALL CLEAR
  256.          WRITE ( NWRITE, 910 )
  257.          READ ( NREAD, 920 )
  258.          CALL CLEAR
  259.          CALL NSTAT ( IX, IY, NUM, DOWN )
  260.          CALL WRITA3 ( NWRITE, NUM, IARRAY, IARRAY2, IARRAY3, ISTART )
  261.          CALL GOTOXY ( NWRITE, IX, IY )
  262.       ELSE
  263. C
  264. C ----- INPUT LINE
  265. C
  266.          IF ( LENGTH(STRING) .EQ. 0 ) THEN
  267. C
  268. C -------- POSITION CURSOR ONLY
  269. C
  270.             IF ( DOWN ) THEN
  271.                IF ( IPTR .LT. NUM ) THEN
  272.                   IPTR = IPTR + 1
  273.                   IY = IY + 1
  274.                   IF ( IY .GT. 23 ) THEN
  275. C
  276. C  --------------  SCROLL UP
  277. C
  278.                      IY = 23
  279.                      ISTART = ISTART + 1
  280.                      CALL WRITL3 ( NWRITE, IY+1, IPTR, IARRAY, IARRAY2,
  281.      $                             IARRAY3 )
  282.                      WRITE ( NWRITE, 940 )
  283.                      CALL REVLF ( NWRITE )
  284.                   ENDIF
  285.                ELSE
  286.                   CALL REVLF ( NWRITE )
  287.                ENDIF
  288.             ELSE
  289.                IF ( IPTR .GT. 1 ) THEN
  290.                   IPTR = IPTR - 1
  291.                   IY = IY - 1
  292.                   IF (IY .LT. 2 ) THEN
  293. C
  294. C  --------------  DOWN SCROLL
  295. C
  296.                      IY = 2
  297.                      ISTART = IPTR
  298.                      CALL GOTOXY ( NWRITE, IX, IY )
  299.                      WRITE ( NWRITE, 930 ) ESC
  300.                      CALL WRITL3 ( NWRITE, IY, IPTR, IARRAY, IARRAY2,
  301.      $                             IARRAY3 )
  302.                   ENDIF
  303.                ENDIF
  304.                CALL GOTOXY ( NWRITE, IX, IY )
  305.             ENDIF
  306.          ELSE
  307. C
  308. C ------ MODIFY LINE
  309. C
  310.             IL = 1
  311.             IA = 0
  312. 200         CALL GETOKE ( STRING, 80, IL, TOKE, TYPE, ERR )
  313.             IF ( TYPE .EQ. 'E' ) THEN
  314.                CALL WRITL3 ( NWRITE, IY, IPTR, IARRAY, IARRAY2,
  315.      $                       IARRAY3 )
  316.                GO TO 100
  317.             ENDIF
  318.             IF (( TYPE .NE. 'I' ) .OR. ERR ) THEN
  319.                CALL MBELL ( NWRITE )
  320.                CALL STAT ( IX, IY, ' Unintelligible input. ' )
  321.                CALL WAIT ( 3 )
  322.                CALL NSTAT ( IX, IY, NUM, DOWN )
  323.                CALL WRITL3 (NWRITE, IY, IPTR, IARRAY, IARRAY2, IARRAY3)
  324.                GO TO 100
  325.             ENDIF
  326.             IA = IA + 1
  327.             IF ( IA .GT. NARRAY ) THEN
  328.                CALL MBELL ( NWRITE )
  329.                CALL STAT ( IX, IY, ' Extra data on line ignored. ' )
  330.                CALL WAIT ( 3 )
  331.                CALL NSTAT ( IX, IY, NUM, DOWN )
  332.                CALL WRITL3 (NWRITE, IY, IPTR, IARRAY, IARRAY2, IARRAY3)
  333.                GO TO 100
  334.             ENDIF
  335. C
  336. C -------  PUT NEW VALUE IN ARRAY
  337. C
  338.             CALL RIGHT ( TOKE )
  339.             IF ( IA .EQ. 1 ) THEN
  340.                READ ( TOKE, 950 ) IARRAY ( IPTR )
  341.             ELSE IF ( IA .EQ. 2 ) THEN
  342.                READ ( TOKE, 950 ) IARRAY2 ( IPTR )
  343.             ELSE
  344.                READ ( TOKE, 950 ) IARRAY3 ( IPTR )
  345.             ENDIF
  346.             GO TO 200
  347.          ENDIF
  348.       ENDIF
  349.       GO TO 100
  350. C
  351. C --- END REPEAT UNTIL
  352. C
  353. 1000  CALL SRESET ( NWRITE )
  354.       CALL CLEAR
  355.       RETURN
  356. 900   FORMAT ( A80 )
  357. 910   FORMAT (///,' A command is a line with a single letter on it :',/,
  358.      $ '    A)dd     - add a blank line to the end of the arrays',/,
  359.      $ '    B)egin   - go to the beginning of the arrays',/,
  360.      $ '    D)elete  - delete the current line',/,
  361.      $ '    E)nd     - go to the end of the arrays',/,
  362.      $ '    I)nsert  - insert a line before the indicated line',/,
  363.      $ '    Q)uit    - exit the editor',/,
  364.      $ '    R)epaint - repaint the screen',/,
  365.      $ '    S)croll  - change the direction of scrolling',/,
  366.      $ '    ? - produce this message',///,
  367.      $ ' Any other line is expected to be data.  Enter ^Z (control/Z)',
  368.      $ /,'  to exit the editor.',//,
  369.      $ ' Enter <CR> to continue.')
  370. 920   FORMAT ( A )
  371. 930   FORMAT ('+',A1,'M',$ )
  372. 940   FORMAT ( / )
  373. 950   FORMAT ( 10X,I10 )
  374.       END
  375. C
  376. C---END NAE3
  377. C
  378.